home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / os2 / timidsrc.zip / misc.tcl < prev    next >
Text File  |  1996-03-29  |  6KB  |  221 lines
  1. #----------------------------------------------------------------
  2. # Miscellaneous procedures
  3. # written by T.IWAI
  4. #----------------------------------------------------------------
  5.  
  6. #----------------------------------------------------------------
  7. # tk easy programming
  8. #----------------------------------------------------------------
  9.  
  10. if [catch {expr $tk_priv(new_tcltk) == 0 || $tk_priv(new_tcltk) == 1}] {
  11.     set tk_priv(new_tcltk) 0
  12.     if [regexp "(\[0-9\]+\.\[0-9\]+)" $tk_patchLevel cur] {
  13.     if {$cur >= 4.0} {
  14.         set tk_priv(new_tcltk) 1
  15.     }
  16.     }
  17. }
  18.  
  19. #
  20. # numeric binding:
  21. # only numerical key and some controls are available for input.
  22. #
  23. proc numeric-bind {w} {
  24.     bind $w <Any-Key> {
  25.     if {"%A" != "" && [regexp "\[0-9\]+" %A]} {
  26.         %W insert insert %A
  27.         tk_entrySeeCaret %W
  28.     } elseif {"%K" == "Return"} {
  29.         global tk_priv
  30.         focus none
  31.     }
  32.     }
  33.     bind $w <Key-Delete> {tk_entryBackspace %W; tk_entrySeeCaret %W}
  34.     bind $w <Key-BackSpace> {tk_entryBackspace %W; tk_entrySeeCaret %W}
  35.     bind $w <Control-Key-h> {tk_entryBackspace %W; tk_entrySeeCaret %W}
  36.     bind $w <Control-Key-d> {%W delete sel.first sel.last; tk_entrySeeCaret %W}
  37.     bind $w <Control-Key-u> {%W delete 0 end}
  38. }
  39.  
  40. #
  41. # make a listbox
  42. #
  43. proc my-listbox {w title size {dohoriz 1} {multiple 0}} {
  44.     global tk_priv
  45.     frame $w
  46.     label $w.label -text $title -relief flat
  47.     pack $w.label -side top -fill x -anchor w
  48.     scrollbar $w.yscr -command "$w.list yview"
  49.     pack $w.yscr -side right -fill y
  50.     if {$tk_priv(new_tcltk)} {
  51.     regexp "(\[0-9\]+)x(\[0-9\])" $size foo width height
  52.     set lopt [list -width $width -height $height]
  53.     if {$multiple} {
  54.         lappend lopt -selectmode multiple
  55.     }
  56.     } else {
  57.     set lopt [list -geometry $size]
  58.     }
  59.     if {$dohoriz} {
  60.     scrollbar $w.xscr -command "$w.list xview" -orient horizontal
  61.     pack $w.xscr -side bottom -fill x
  62.     eval listbox $w.list -relief sunken -setgrid yes $lopt\
  63.         [list -yscroll "$w.yscr set"]\
  64.         [list -xscroll "$w.xscr set"]
  65.     } else {
  66.     eval listbox $w.list -relief sunken -setgrid yes $lopt\
  67.         [list -yscroll "$w.yscr set"]
  68.     }
  69.     pack $w.list -side left -fill both -expand yes
  70.     return $w.list
  71. }
  72.  
  73. #----------------------------------------------------------------
  74. # dialog pop-up
  75. #----------------------------------------------------------------
  76.  
  77. proc my-dialog {w title defbtn canbtn buttons} {
  78.     toplevel $w -class Dialog
  79.     wm title $w $title
  80.     wm iconname $w $title
  81.  
  82.     label $w.title -text $title -relief raised -bd 1
  83.     pack $w.title -side top -fill x
  84.     
  85.     frame $w.f -relief raised -bd 1
  86.     pack $w.f -side top -fill both
  87.  
  88.     frame $w.buttons -relief raised -bd 1
  89.     pack $w.buttons -side bottom -fill both
  90.     set i 0
  91.     foreach but $buttons {
  92.     button $w.buttons.c$i -text [lindex $but 0] -command [lindex $but 1]
  93.     if {$defbtn != "" && $i == $defbtn} {
  94.         frame $w.buttons.default -relief sunken -bd 1
  95.         raise $w.buttons.c$i $w.buttons.default
  96.         pack $w.buttons.default -side left -expand 1\
  97.             -padx 3m -pady 2m
  98.         pack $w.buttons.c$i -in $w.buttons.default -padx 2m -pady 2m \
  99.             -ipadx 2m -ipady 1m
  100.         bind $w <Return> "$w.buttons.c$i flash; $w.buttons.c$i invoke"
  101.     } else {
  102.         pack $w.buttons.c$i -side left -expand 1 \
  103.             -padx 3m -pady 3m -ipadx 2m -ipady 1m
  104.         if {$canbtn != "" && $i == $canbtn} {
  105.         bind $w <Key-Escape> "$w.buttons.c$i flash; $w.buttons.c$i invoke"
  106.         }
  107.     }
  108.     incr i
  109.     }
  110.  
  111.     return $w.f
  112. }
  113.  
  114. #----------------------------------------------------------------
  115. #  warning/question dialog
  116. #----------------------------------------------------------------
  117.  
  118. if {$tk_priv(new_tcltk)} {
  119.     proc my-message-dialog {w title text bitmap defbtn canbtn args} {
  120.     #puts stderr $text
  121.     return [eval tk_dialog [list $w $title $text $bitmap $defbtn] $args]
  122.     }
  123. } else {
  124.     proc my-message-dialog {w title text bitmap defbtn canbtn args} {
  125.     #puts stderr $text
  126.     global tk_priv
  127.     set butlist {}
  128.     set num 0
  129.     foreach i $args {
  130.         lappend butlist [list $i "set tk_priv(button) $num; destroy $w"]
  131.         incr num
  132.     }
  133.     set f [my-dialog $w $title $defbtn $canbtn $butlist]
  134.     set num 0
  135.     message $f.msg -width 3i -text $text
  136.     pack $f.msg -side right -expand 1 -fill both -padx 5m -pady 5m
  137.     if {$bitmap != ""} {
  138.         label $f.bitmap -bitmap $bitmap
  139.         pack $f.bitmap -side left -padx 5m -pady 5m
  140.     }
  141.     set tk_priv(button) 0
  142.  
  143.     wm withdraw $w
  144.     update idletasks
  145.     set x [expr [winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
  146.         - [winfo vrootx [winfo parent $w]]]
  147.     set y [expr [winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
  148.         - [winfo vrooty [winfo parent $w]]]
  149.     wm geom $w +$x+$y
  150.     wm deiconify $w
  151.  
  152.     set oldFocus [focus]
  153.     grab $w
  154.     tkwait window $w
  155.     focus $oldFocus
  156.  
  157.     return $tk_priv(button)
  158.     }
  159. }
  160.  
  161. proc warning {message} {
  162.     my-message-dialog .warning "Warning" $message warning 0 0 {  OK  }
  163. }
  164.  
  165. proc error {message} {
  166.     my-message-dialog .error "Error" $message error 0 0 {  OK  }
  167. }
  168.     
  169. proc information {message} {
  170.     my-message-dialog .info "Information" $message info 0 0 {  OK  }
  171. }
  172.     
  173. proc question {message {defrc 1}} {
  174.     global tk_priv
  175.     if {$defrc} {
  176.     set defbtn 0
  177.     set canbtn 1
  178.     } else {
  179.     set defbtn 1
  180.     set canbtn 0
  181.     }
  182.     return [expr ![my-message-dialog .yesno "Question" $message question\
  183.         $defbtn $canbtn "Yes" "No"]]
  184. }
  185.  
  186. #----------------------------------------------------------------
  187. # get the root file name from full path
  188. #----------------------------------------------------------------
  189.  
  190. proc rootname {path} {
  191.     if {$path == "/"} {
  192.     return $path
  193.     } elseif [regexp "\[^/\]+$" $path base] {
  194.     return $base
  195.     } elseif [regexp "(\[^/\]+)/$" $path rest base] {
  196.     return $base
  197.     } else {
  198.     return $path
  199.     }
  200. }
  201.  
  202. #----------------------------------------------------------------
  203. # pseudo random without TclX using bash -- quick and dirty hack!!
  204. #----------------------------------------------------------------
  205.  
  206. set pseudo_random [catch {random 1}]
  207. proc my-random {max} {
  208.     global pseudo_random
  209.     if {$pseudo_random} {
  210.     return [expr [exec bash -c {echo $RANDOM}] % $max]
  211.     } else {
  212.     return [random $max]
  213.     }
  214. }
  215. proc init-random {num} {
  216.     global pseudo_random
  217.     if {!$pseudo_random} {
  218.     random seed $num
  219.     }
  220. }
  221.